(define-library (packrat)
  (export make-grammar
          define-grammar
          parse)
  (import (scheme base)
          (scheme lazy)
          (srfi 14)
          (packrat helpers)
          (packrat datatypes))
  (cond-expand
   (chibi (import (chibi match)))
   (chicken (import (matchable)))
   (cyclone (import (cyclone match)))
   (gauche (import (util match)))
   (guile (import (ice-9 match)))
   (mosh (import (match)))
   (sagittarius (import (match)))
   ;; The SRFI has been withdrawn, but anyway you need a Wright-Cartwright-Shinn
   ;; pattern matcher.
   (else (import (srfi 204))))
  (begin

    ;; :: <procedure <grammar> <reader> <source> <location>>
    (define parser-main
      (lambda (grammar reader source) (as loc
        (make-location
         (map (match-lambda ((term . def)
                (cons term
                      (delay (parser-term grammar term loc)))))
              (grammar-contents grammar))
         (delay (let ((token (reader source))) ; the order of evaluation is significant
                  (make-result #t ; token result is always successful
                    token
                    (parser-main grammar reader source)
                    #t)))))))

    ;; :: <procedure <grammar> <term> <location> <result>>
    (define parser-term (lambda (grammar term location)
      (match (assq term (grammar-contents grammar)) ((term spec action)
        (let ((tsf (rtssw action)))
          (tsf (let loop-spec ((s spec) (l location))
            (match s
             ('_
              (location-read l))
             ((? procedure?) ; <token predicate>
              (let ((res (location-read l))) ; always successful
                (if (s (result-semantics res))
                    res
                    (result-deny res term))))
             ((? char?)
              (loop-spec (lambda (char) (eq? char s)) l))
             ((? char-set?)
              (loop-spec (lambda (char) (char-in? char s)) l))
             (('= raw)
              (loop-spec (lambda (token) (equal? token raw)) l))
             ((? symbol?) ; <term>
              (location-query s l))
             (('! subspec)
              (let ((res (loop-spec subspec l)))
                (if (result-success? res)
                    (result-deny res term)
                    (make-result #t (list) l term))))
             (('& sss ...)
              (let loop-and ((cur-res (loop-spec (car sss) l))
                             (rem-sss (cdr sss)))
                (if (or (result-failure? cur-res) (null? rem-sss))
                    cur-res
                    (loop-and (loop-spec (car rem-sss) l)
                              (cdr rem-sss)))))
             (('/ sss ...)
              (let loop-or ((cur-res (loop-spec (car sss) l))
                            (rem-sss (cdr sss)))
                (if (or (result-success? cur-res) (null? rem-sss))
                    cur-res
                    (loop-or (loop-spec (car rem-sss) l)
                             (cdr rem-sss)))))
             (('~ sss ...)
              (let loop-seq ((for-sem (list))
                             (cur-res (loop-spec (car sss) l))
                             (rem-sss (cdr sss)))
                (cond
                 ((result-failure? cur-res)
                  cur-res)
                 ((null? rem-sss)
                  (make-result #t
                    (reverse (cons (result-semantics cur-res) for-sem))
                    (result-residue cur-res)
                    term))
                 (else
                  (loop-seq (cons (result-semantics cur-res) for-sem)
                            (loop-spec (car rem-sss) (result-residue cur-res))
                            (cdr rem-sss))))))
             (('? subspec)
              (let ((res (loop-spec subspec l)))
                (if (result-success? res)
                    (obo rtssw list res)
                    (make-result #t (list) l term))))
             (('* subspec)
              (let loop-repeat ((for-sem (list))
                                (for-rsd l)
                                (cur-res (loop-spec subspec l)))
                (if (result-failure? cur-res)
                    (make-result #t (reverse for-sem) for-rsd term)
                    (loop-repeat (cons (result-semantics cur-res) for-sem)
                                 (result-residue cur-res)
                                 (loop-spec subspec (result-residue cur-res))))))
             (('+ subspec)
              (obo rtssw
               (lambda (ls)
                 (cons (car ls) (cadr ls)))
               (loop-spec `(~ ,subspec (* ,subspec)) l)))))))))))

    ;; :: <procedure <term> <grammar> <semantics>>
    (define parse
      (lambda (grammar reader source term)
        (let ((result (location-query term (parser-main grammar reader source))))
          (if (result-success? result)
              (result-semantics result)
              (error "parsing failed"
                     (result-semantics result) (result-context result) source)))))

  )
)
